home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / Clut fade 1.3.2 Folder.sit / Clut fade 1.3.2 Folder / clut_fade 1.3.2 / Pascal / fade.p < prev    next >
Text File  |  1996-04-25  |  17KB  |  545 lines
  1. unit Fade;
  2. interface
  3.  
  4. {/********************************************************************************        }
  5. {                                                                                        }
  6. {     PROJECT:    clut_fade.ｹ                                                                }
  7. {                                                                                         }
  8. {     FILE:        fade.p                                                                    }
  9. {                                                                                         }
  10. {     PURPOSE:    'clut' fading functions                                                    }
  11. {                                                                                         }
  12. {     ??/??/93    1.0 written by N. Jonas Englund                                            }
  13. {     07/26/94    1.1 Changes by Mark Womack to allow fading all monitors, only the        }
  14. {                 main monitor, or all monitors except the main monitor.  Cleaned         }
  15. {                 up the fade.h to hide more structures, and removed almost all global    }
  16. {                 space used (My changes grew the global space by 10 times so I figured    }
  17. {                 it needed to be fixed).  Current code is limited to 10 monitors max,    }
  18. {                 but is easily cofigurable for more if you think you need it.            }
  19. {     10/21/94    Changes by Mark Womack to make pascal friendly, fix < 256 color            }
  20. {                 crasher, cleaned up to make more readable.                                }
  21. {     10/24/94    Integrated fade_to_clut function written by Macneil Shonle.                }
  22. {                 Added copy_gdevice_clut function to make it easier to save                }
  23. {                 and restore device clut's.                                                }
  24. {                  Added fade_to_color function which uses both the fade_to_clut            }
  25. {                  and copy_gdevice_clut functions to fade to a given rgb value.            }
  26. {    03/05/96    Translated to Pascal by C. Franz (cfranz@home.malg.imp.com)                }
  27. {                Written for THINK Pascal. To port to other Pascal dialects you            }
  28. {                must check what the 'continue' command in C corresponds to. It's        }
  29. {                'CYCLE' in THINK Pascal                                                    }
  30. {                                                                                        }
  31. {     =-=-= PLEASE SEE THE README THAT ACCOMPANIED THIS PROJECT FOR DETAILS =-=-=            }
  32. {                                                                                         }
  33. {     This software is considered Public Domain. You are free to use it in any            }
  34. {     manner you wish. You are free to upload it to your favorite service, but            }
  35. {     you must post it with the accompanying readme and description files.                }
  36. {     If you use or appreciate it, please let us know!! We all love to get email.            }
  37. {     See the addresses below.                                                            }
  38. {                                                                                         }
  39. {     This software is offered 'as is'. The authors are not responsible for any            }
  40. {     damages caused by bugs or defects that might be lurking. But if it blows up            }
  41. {     your monitor, please let us know. If you find any bugs, problems, enhancements,        }
  42. {     please contact us.                                                                    }
  43. {                                                                                         }
  44. {     Email Addresses:  MarkWomack@aol.com, MacneilS@aol.com, KenLong@aol.com.            }
  45. {                                                                                        }
  46. { ********************************************************************************/        }
  47.  
  48.  
  49.     const
  50.         fadeMainOnly = 1;    {#define    fadeMainOnly    1}
  51.         fadeAll = 2;        {#define    fadeAll            2}
  52.         fadeAllButMain = 4;    {#define    fadeAllButMain    4}
  53.  
  54.  
  55.     const
  56.         MAXCOLORS = 256;
  57.         gMaxDevices = 10;
  58.  
  59.  
  60.     type    {typedef struct FadeValues}
  61.         FadeValues = record
  62.                 reds: array[0..255] of integer;
  63.                 greens: array[0..255] of integer;
  64.                 blues: array[0..255] of integer;
  65.             end; {FadeValues;}
  66.  
  67.  
  68. {//===== PUBLIC FUNCTIONS =====//}
  69. { These are the actual 'work' procedures }
  70.  
  71.     procedure fade_to_black (numSteps: longint; fadeFlags: integer; fadeOut: boolean);
  72.     procedure fade_to_clut (numSteps: longint; destTab: CTabHandle; aGDevice: GDHandle);
  73.     procedure fade_to_color (numSteps: longint; var destColor: RGBColor; aGDevice: GDHandle);
  74.  
  75. { some misc procedures to manipulate CLUTs }
  76.     procedure copy_gdevice_clut (aGDevice: GDHandle; var copyOfClut: CTabHandle);
  77.         { returns a handle to a newly allocated copy of clut }
  78.  
  79.     procedure copy_cluts (hGD: GDHandle; var gFade: CTabHandle; var gOrig: CTabHandle);
  80.         { given a GDevice, it returns the devices CLUT in gFade and a Handle to a newly     }
  81.         { allocated copy in gOrig                                                                 }
  82.  
  83.  
  84. implementation
  85.  
  86. {//================================= FUNCTIONS ===================================    }
  87. { Remember, the fade routines are translated from C.                                }
  88. { Because C is arcane we need to forward declare some functions.                       }
  89. { because of this, we simply define them in the Interface section, so they can be     }
  90. { accessed internally                                                                     }
  91.  
  92.     procedure calc_fade (numSteps: longint; gFade: CTabHandle; var rgbs: FadeValues);
  93.     FORWARD;
  94.     procedure fade_out (fadeLevel: longint; gFade: CTabHandle; rgbs: FadeValues);
  95.     FORWARD;
  96.     procedure fade_in (fadeLevel: longint; gFade: CTabHandle; gOrig: CTabHandle; rgbs: FadeValues);
  97.     FORWARD;
  98.     procedure black_out (gFade: CTabHandle);
  99.     FORWARD;
  100.     procedure restore_clut (gFade: CTabHandle; gOrig: CTabHandle);
  101.     FORWARD;
  102.  
  103.  
  104. {/ ********************************** fade_to_black ****************************** /}
  105.     procedure fade_to_black (numSteps: longint; fadeFlags: integer; fadeOut: boolean);{pascal void fade_to_black(long numSteps, short fadeFlags, Boolean fadeOut)}
  106. {}
  107.         var
  108.             oldDev, hGD: GDHandle;
  109.             gdHdls: array[0..gMaxDevices] of GDHandle;
  110.             rgbs: array[0..gMaxDevices] of FadeValues;
  111.             gFade: array[0..gMaxDevices] of CTabHandle;
  112.             gOrig: array[0..gMaxDevices] of CTabHandle;
  113.             x, numDevices, stepCount: integer;
  114.  
  115.             stepper: integer;             (* used to clean up convoluted C code FOR loop *)
  116.             notDone: Boolean;            (* see above *)
  117.  
  118.     begin
  119.     {// initialize}
  120.         oldDev := GetGDevice;
  121.  
  122.     {now comes a cool expression in C: hGD = (!!(fadeFlags & fadeMainOnly != 0)) ? GetMainDevice() : GetDeviceList();}
  123.     {this resolves to }
  124.         if (BitAND(fadeFlags, fadeMainOnly) <> 0) then
  125.             hGD := GetMainDevice
  126.         else
  127.             hGD := GetDeviceList;                {I really, really hate C. Why did they have to write such a convoluted        }
  128.                                             {statement? It's *very* hard to understand, maintain or debug. What a    }
  129.                                             {piece of crap. The pascal equivalent is much easier to understand.             }
  130.                                             {Also, it generates *much* tighter object code... tsk, tsk.                    }
  131.  
  132.         numDevices := 0;
  133.  
  134.     {// make a list of the affected gdevices}
  135.     { a typical C damned-if-you-can-read-me while: while (hGD && numDevices < gMaxDevices))}
  136.  
  137.         while (hGD <> nil) and (numDevices < gMaxDevices) do
  138.             begin
  139.         {// skip main device if fadeAllButMain flag}
  140.                 if TestDeviceAttribute(hGD, mainScreen) and (BitAND(fadeFlags, fadeAllButMain) <> 0) then
  141.                     begin
  142.                         hGD := hGD^^.gdNextGD;
  143.                         cycle;                            {you can easily tell this was originally C code if I have to resort to }
  144.                     end;                                {the cycle statement.                                                    }
  145.  
  146.  
  147.                 if TestDeviceAttribute(hGD, screenDevice) then
  148.                     begin
  149.                         gdHdls[numDevices] := hGD;
  150.                         numDevices := numDevices + 1;
  151.                     end;                                            { if }
  152.  
  153.  
  154.         {// stop now if only fading main device}
  155.                                                         {if (!!(fadeFlags & fadeMainOnly != 0))}
  156.                                                             {break;}
  157.  
  158.                                                         {hGD = (GDHandle)(*hGD)->gdNextGD;}
  159.  
  160.         {previous extremely ugly code will be resolved to a much more    }
  161.         {elegant method. Instead of jumping out of the loop, we fulfill    }
  162.         {the break condition -- hGD equals NIL:                             }
  163.  
  164.                 if BitAND(fadeFlags, fadeMainOnly) <> 0 then
  165.                     hGD := nil
  166.                 else
  167.                     hGD := hGD^^.gdNextGD;
  168.  
  169.             end;                                                { while }
  170.  
  171.     {// calculate the fade cluts for each device}
  172.         x := 0;
  173.         while x < numDevices do
  174.             begin
  175.                 SetGDevice(gdHdls[x]);
  176.                 copy_cluts(gdHdls[x], gFade[x], gOrig[x]);
  177.                 calc_fade(numSteps, gFade[x], rgbs[x]);
  178.                 x := x + 1;
  179.             end;                                                        { while }
  180.  
  181.      {// fade each device}
  182.      {// I know this is unreadable (dontcha love C?), the idea is to count down on}
  183.      {// fadeout and count up on fade in.}
  184.     { well -- at least they admit it. It IS unreadable }
  185.     {eat this: }
  186.                  {for (stepCount = fadeOut ? numSteps : 0; fadeOut ? stepCount >= 0 : stepCount < numSteps; fadeOut ? stepCount-- : stepCount++)}
  187.     {I resolved this stupid code the following way: }
  188.     {        stepper -- holds either -1 (count down for fade out ) or 1 (count up) }
  189.     {        notDone -- true until we went through all steps}
  190.  
  191.         if fadeOut then
  192.             stepcount := numSteps
  193.         else
  194.             stepCount := 0;
  195.  
  196.         if fadeOut then
  197.             stepper := -1
  198.         else
  199.             stepper := 1; (* no equivalent *)
  200.  
  201.         if fadeOut then
  202.             notDone := stepCount >= 0
  203.         else
  204.             notDone := stepCount < numSteps; (* no equivalent - used to clean up loop *)
  205.  
  206.         while notDone do
  207.             begin
  208.                 x := 0;
  209.                 while x < numDevices do
  210.                     begin
  211.                         SetGDevice(gdHdls[x]);
  212.                         if fadeOut then
  213.                             fade_out(stepCount, gFade[x], rgbs[x])
  214.                         else
  215.                             fade_in(stepCount, gFade[x], gOrig[x], rgbs[x]);
  216.                         x := x + 1;
  217.                     end;
  218.  
  219.                 stepCount := stepCount + stepper;
  220.                 if fadeOut then
  221.                     notDone := stepCount >= 0
  222.                 else
  223.                     notDone := stepCount < numSteps;
  224.  
  225.             end;                                                {baaad for loop -- while not done}
  226.  
  227.     {// restore each devices clut, and dispose of temp memory}
  228.         x := 0;
  229.         while x < numDevices do
  230.             begin
  231.                 SetGDevice(gdHdls[x]);
  232.                 restore_clut(gFade[x], gOrig[x]);
  233.                 DisposeHandle(Handle(gOrig[x]));
  234.                 x := x + 1;
  235.             end;
  236.  
  237.     {// set original device}
  238.         SetGDevice(oldDev);
  239.     end;
  240.  
  241.  
  242.     procedure AdjustOne (var rgb: integer; delta: integer);
  243.         var
  244.             theColor: longint;
  245.  
  246.     begin
  247.         theColor := BitAND(rgb, $0000FFFF);
  248.         theColor := theColor - delta;
  249.         rgb := loword(theColor);
  250.     end;
  251.  
  252.  
  253. {/ *********************************** fade_to_clut ******************************* /}
  254.     procedure fade_to_clut (numSteps: longint; destTab: CTabHandle; aGDevice: GDHandle);
  255.  
  256. {}
  257.         var
  258.             srcTab: CTabHandle;                                { // get the monitorﾕs current clut}
  259.             redDelta: array[0..MaxColors] of longint;        {// We want the range for each color to be of an}
  260.             greenDelta: array[0..MaxColors] of longint;    {// unsigned short, but we need negative numbers.}
  261.             blueDelta: array[0..MaxColors] of longint;        {// So these longs are the solution.}
  262.             difference: longint;                                {// used to clear up clutter in the code}
  263.             i: longint;                                        {// to cycle trough for loops}
  264.             colorIndex: longint;                                {// to cycle through arrays}
  265.             oldGDevice: GDHandle;
  266.             l1, l2: longint;                                    {pascal conversion}
  267.  
  268.     begin
  269.         srcTab := aGDevice^^.gdPMap^^.pmTable;
  270.         oldGDevice := GetGDevice;
  271.  
  272.         SetGDevice(aGDevice);                                {// set it to the monitor to be faded}
  273. { }
  274. {    {/**** Set up the deltas ****/}
  275.         i := 0;
  276.         while i <= destTab^^.ctSize do
  277.             begin
  278.     {    /*    This is what I am thinking: take the difference between the two colors and divide    }
  279.     {        it by the number of steps (numSteps). So we will have a number that can be added    }
  280.     {        to the source numSteps times and have it end up equaling the destination.            }
  281.     {    */                                                                                        }
  282.  
  283.                 l1 := BitAND(srcTab^^.ctTable[i].rgb.red, $0000FFFF); (* make it longint without going negative *)
  284.                 l2 := BitAND(destTab^^.ctTable[i].rgb.red, $0000FFFF); (* same as above *)
  285.                 difference := l1 - l2;
  286.                 redDelta[i] := loword(difference div numSteps);
  287.  
  288.                 l1 := BitAND(srcTab^^.ctTable[i].rgb.green, $0000FFFF);
  289.                 l2 := BitAND(destTab^^.ctTable[i].rgb.green, $0000FFFF);
  290.                 difference := l1 - l2;
  291.                 greenDelta[i] := loword(difference div numSteps);
  292.  
  293.                 l1 := BitAND(srcTab^^.ctTable[i].rgb.blue, $0000FFFF);
  294.                 l2 := BitAND(destTab^^.ctTable[i].rgb.blue, $0000FFFF);
  295.                 difference := l1 - l2;
  296.                 blueDelta[i] := loword(difference div numSteps);
  297.                 i := i + 1;
  298.             end;
  299.  
  300.  
  301. {/ **** Do the fade **** / }
  302.  
  303.         i := 0;
  304.         while i < numSteps do
  305.             begin
  306.                 colorIndex := 0;
  307.                 while colorIndex <= destTab^^.ctSize do
  308.                     begin
  309.                         AdjustOne(srcTab^^.ctTable[colorIndex].rgb.red, redDelta[colorIndex]);
  310.                         AdjustOne(srcTab^^.ctTable[colorIndex].rgb.green, greenDelta[colorIndex]);
  311.                         AdjustOne(srcTab^^.ctTable[colorIndex].rgb.blue, blueDelta[colorIndex]);
  312.                         colorIndex := colorIndex + 1;
  313.                     end;
  314.  
  315.                 SetEntries(0, srcTab^^.ctSize, srcTab^^.ctTable);
  316.                 i := i + 1;
  317.             end;
  318.  
  319.  
  320.         SetEntries(0, destTab^^.ctSize, destTab^^.ctTable);
  321.         srcTab^^.ctSeed := destTab^^.ctSeed; { set the ctSeed too }
  322.         MakeITable(nil, nil, 0);
  323.  
  324.         SetGDevice(oldGDevice);
  325.     end;
  326.  
  327.  
  328.  
  329.  
  330.     procedure fade_to_color (numSteps: longint; var destColor: RGBColor; aGDevice: GDHandle);
  331.  
  332. {}
  333.         var
  334.             newColors: CTabHandle;
  335.             x: integer;
  336.  
  337.     begin
  338.  
  339.     {// get copy of the current color table}
  340.         copy_gdevice_clut(aGDevice, newColors);
  341.  
  342.     {// make the color table all one color}
  343.         x := 0;
  344.         while x <= newColors^^.ctSize do
  345.             begin
  346.                 newColors^^.ctTable[x].rgb := destColor;
  347.                 x := x + 1;
  348.             end;
  349.         newColors^^.ctSeed := GetCTSeed;    { change the ctSeed so we know it is different }
  350.  
  351.     {// fade to the custom color table}
  352.         fade_to_clut(numSteps, newColors, aGDevice);
  353.  
  354.     {// dispose color table}
  355.         DisposeHandle(Handle(newColors));
  356.     end;
  357.  
  358.  
  359.     procedure copy_gdevice_clut (aGDevice: GDHandle; var copyOfClut: CTabHandle);
  360.  
  361.         var
  362.             srcTab: CTabHandle;
  363.             dummy: integer;
  364.  
  365.     begin
  366.         srcTab := aGDevice^^.gdPMap^^.pmTable;
  367.  
  368.         dummy := HandToHand(Handle(srcTab));
  369.         copyOfClut := srcTab;
  370.     end;
  371.  
  372.  
  373.  
  374.  
  375. {    / / = = = = = PRIVATE FUNCTIONS = = = = = / /}
  376.  
  377. {/ ********************************** copy_cluts ********************************** /}
  378.     procedure copy_cluts (hGD: GDHandle; var gFade: CTabHandle; var gOrig: CTabHandle);
  379.  
  380.         var
  381.             gTempH: Handle;
  382.             dummy: integer;
  383.  
  384.     begin
  385.         gFade := hGD^^.gdPMap^^.pmTable;
  386.         gTempH := Handle(hGD^^.gdPMap^^.pmTable);
  387.         dummy := HandToHand(gTempH);
  388.         gOrig := CTabHandle(gTempH);
  389.  
  390.         HLock(Handle(gFade));
  391.         HLock(Handle(gOrig));
  392.     end;
  393.  
  394.  
  395.  
  396. {/ *********************************** calc_fade ********************************** /}
  397.     procedure calc_fade (numSteps: longint; gFade: CTabHandle; var rgbs: FadeValues);
  398.  
  399. {}
  400.         var
  401.             i: integer;
  402.             calcval: longint;
  403.  
  404.     begin
  405.         i := 0;
  406.         while i <= gFade^^.ctSize do
  407.             begin
  408.                 calcval := bitAND(gFade^^.ctTable[i].rgb.red, $0000ffff);
  409.                 calcval := calcval div numSteps;
  410.                 rgbs.reds[i] := calcval;
  411.  
  412.  
  413.                 calcval := bitand(gFade^^.ctTable[i].rgb.green, $0000ffff);
  414.                 calcval := calcval div numSteps;
  415.                 rgbs.greens[i] := calcval;
  416.  
  417.  
  418.                 calcval := bitand(gFade^^.ctTable[i].rgb.blue, $0000ffff);
  419.                 calcval := calcval div numSteps;
  420.                 rgbs.blues[i] := calcval;
  421.                 i := i + 1;
  422.             end;
  423.  
  424.     end;
  425.  
  426. (* Help proc for conversion of integer to longint without extending hi-word *)
  427.     procedure fadeone (var rgbval: integer; difference: longint);
  428.         var
  429.             colorVal: longint;
  430.  
  431.     begin
  432.         colorVal := bitAND(rgbVal, $0000FFFF);
  433.         if colorval > difference then
  434.             colorval := colorval - difference;
  435.         rgbval := loword(colorval);
  436.     end;
  437.  
  438. {/ ********************************** fade_out ********************************** /}
  439.     procedure fade_out (fadeLevel: longint; gFade: CTabHandle; rgbs: FadeValues);
  440.  
  441. {}
  442.         var
  443.             i: integer;
  444.  
  445.     begin
  446.         i := 0;
  447.         while i < gFade^^.ctSize do
  448.             begin
  449.                 fadeone(gFade^^.ctTable[i].rgb.red, rgbs.reds[i]);
  450.                 fadeone(gFade^^.ctTable[i].rgb.green, rgbs.greens[i]);
  451.                 fadeone(gFade^^.ctTable[i].rgb.blue, rgbs.blues[i]);
  452.                 i := i + 1;
  453.             end;
  454.  
  455.         SetEntries(0, gFade^^.ctSize, gFade^^.ctTable);
  456.  
  457.         if fadeLevel = 0 then
  458.             black_out(gFade);
  459.     end;
  460.  
  461.  
  462.  
  463. {/ ********************************** fade_in ********************************** /}
  464.  
  465.     procedure fadeinone (var rgb: integer; target: integer; increment: integer);
  466.  
  467.         var
  468.             color1, color2: longint;
  469.  
  470.     begin
  471.         color1 := BitAND(rgb, $0000FFFF);
  472.         color2 := BitAND(target, $0000FFFF);
  473.         if color1 < color2 then
  474.             color1 := color1 + increment;
  475.         rgb := loword(color1);
  476.     end;
  477.  
  478.     procedure fade_in (fadeLevel: longint; gFade: CTabHandle; gOrig: CTabHandle; rgbs: FadeValues);
  479. {}
  480.         var
  481.             i: integer;
  482.  
  483.     begin
  484.         if fadeLevel = 0 then
  485.             black_out(gFade);
  486.  
  487.         i := 0;
  488.         while i <= gFade^^.ctSize do
  489.             begin
  490.                 fadeinone(gFade^^.ctTable[i].rgb.red, gOrig^^.ctTable[i].rgb.red, rgbs.reds[i]);
  491.                 fadeinone(gFade^^.ctTable[i].rgb.green, gOrig^^.ctTable[i].rgb.green, rgbs.greens[i]);
  492.                 fadeinone(gFade^^.ctTable[i].rgb.blue, gOrig^^.ctTable[i].rgb.blue, rgbs.blues[i]);
  493.                 i := i + 1;
  494.             end;
  495.  
  496.         SetEntries(0, gFade^^.ctSize, gFade^^.ctTable);
  497.     end;
  498.  
  499.  
  500. {/********************************** black_out ********************************** /}
  501.     procedure black_out (gFade: CTabHandle);
  502. {}
  503.         var
  504.             i: integer;
  505.  
  506.     begin
  507.         i := 0;
  508.         while i < gFade^^.ctSize do
  509.             begin
  510.                 gFade^^.ctTable[i].rgb.red := 0;
  511.                 gFade^^.ctTable[i].rgb.green := 0;
  512.                 gFade^^.ctTable[i].rgb.blue := 0;
  513.                 i := i + 1;
  514.             end;
  515.  
  516.         SetEntries(0, gFade^^.ctSize, gFade^^.ctTable);
  517.     end;
  518.  
  519. {    / ********************************** restore_clut ********************************** /}
  520.     procedure restore_clut (gFade: CTabHandle; gOrig: CTabHandle);
  521.  
  522. {}
  523.         var
  524.             i: integer;
  525.  
  526.     begin
  527.  
  528.         i := 0;{}
  529.         while i <= gFade^^.ctSize do
  530.             begin
  531.                 gFade^^.ctTable[i].rgb.red := gOrig^^.ctTable[i].rgb.red;{}
  532.                 gFade^^.ctTable[i].rgb.green := gOrig^^.ctTable[i].rgb.green;{}
  533.                 gFade^^.ctTable[i].rgb.blue := gOrig^^.ctTable[i].rgb.blue;{}
  534.                 i := i + 1;
  535.             end;
  536.  
  537.  
  538.         gFade^^.ctSeed := gOrig^^.ctSeed; { restore the ctSeed too }
  539.         MakeITable(nil, nil, 0);
  540.  
  541.         HUnlock(Handle(gFade));
  542.         HUnlock(Handle(gOrig));
  543.     end;
  544.  
  545. end.